home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops ƒ / Files < prev    next >
Text File  |  1995-11-26  |  14KB  |  599 lines
  1. \ Files  - file object and loader
  2.  
  3. cr .( loading Files...)
  4.  
  5. cl1                        \ In case we're reloading
  6. ' cl1    -> abortVec
  7.     0    -> quitvec
  8.  
  9.  
  10.     0    value        SFDlgHook    \ Used in std file calls.  If non-zero,
  11.                                 \  points to the proc to be called while
  12.                                 \  the std file dialog is up.
  13.  
  14. -39        constant    EOF            \ EOF error return
  15. -43        constant    FNF            \ File not found ditto
  16.  
  17. -300     constant    FILE-MARK
  18. \ Marks the start of a loaded file - we plant some useful info there.
  19. \ We put the file name in the dic as if it's a definition name, but use
  20. \ file-mark as a "handler code".  Then after that we put the useful info.
  21. \ See extrasMod.
  22.  
  23. false    value    ASYNCH?
  24. false    value    ENDLOAD?
  25. false    value    LOG?
  26.  
  27.     0    value    OPEN_CNT
  28.     0    value    CLOSE_ERR_CNT
  29.  
  30. forward    CREATE_LOG
  31. forward    WRITE_LOG
  32.  
  33.     string    $LG1
  34.     string    $LG2
  35.  
  36.  
  37. : ASYNCH    true -> asynch?  ;
  38.  
  39. : IOWAIT    BEGIN  busy  0EXIT  pause  AGAIN   ;
  40.  
  41. : (ASY)        \ ( fcb -- )  Sets up for a low-level asynchronous read or write.
  42.     IOwait
  43.     -> busy  setCP  ;
  44.  
  45.  
  46. : VOLNAME?  { str -- b } 
  47.     reset: [ str ]
  48.     58 str chsearch: [ str ]
  49.     NIF  false  EXIT  THEN
  50.     lim: [ str ]  2 >=  ;
  51.  
  52.  
  53. forward  OPEN_WITH_PATHS
  54.  
  55. false    value    USE_PATHS?
  56.  
  57. : HFS?    $ 3f6 w@x  0>  ;
  58.  
  59. variable    MyDocName    28 allot
  60.  
  61. : MyDoc        \ ( -- addr len )
  62.     MyDocName  count  ;
  63.  
  64.  
  65. \ Standard file package support
  66.  
  67. : SFLOC  {  \ ht wd -- x:y }
  68.         \ Computes screen coordinates for top left of
  69.         \ SF dialog box.  Centers the box horizontally, and a bit above
  70.         \ the center vertically.
  71.     screenbits  -> ht  -> wd  2drop
  72.     ht 3 /  80 -  0 max  -> ht
  73.     wd 2/  170 -  0 max  -> wd
  74.     wd ht pack  ;
  75.  
  76.  
  77. :class     SFrec    super{ object } 
  78.  
  79. record
  80. {    int            Good
  81.     var            fType
  82.     int            vRefNum
  83.     int            Version
  84.  64    bytes        Filename        \ max size is 64
  85. }
  86. 4    ordered-col    fTypes            \ list of filetypes
  87.  
  88.  
  89. :m GetVRefNum:    get: vRefNum   ;m
  90. :m GetName:        addr: FileName   ;m
  91.  
  92. :m CALL:        \ ( routine# -- bool )  Calls a Standard File Package routine.
  93.     SFDlgHook  ^base  rot makeint  trap$ A9EA
  94.     get: good  ;m
  95.  
  96. :m STDGET:  ( type0 ...typeN ) {  #types -- bool } 
  97.     clear: fTypes  #types  0>
  98.     IF    #types 0  DO  add: fTypes  LOOP  THEN
  99.     SFloc  0 0  #types makeint  ixAddr: fTypes
  100.     2 call: self  ;m
  101.  
  102. :m STDPUT:  {  pAddr pLen nAddr nLen -- bool } 
  103.     pAddr pLen pad place
  104.     SFloc  pad  nAddr nLen  str255
  105.     1 call: self  ;m
  106.  
  107. ;class 
  108.  
  109.  
  110. objHandle    SFHDL
  111. objPtr        SFOBJ   class_is  SFrec
  112.  
  113.  
  114. \ DO_OPEN does the hard work for OPEN: file.  First, if either the DirID
  115. \ or the vol ref# is non-zero, we rashly assume we know which folder we
  116. \ want, and just do an open.  We also do that if we're not running under HFS.
  117. \ Then, if we get through to here, we need to look at the paths.  But wait!
  118. \ First, we check the default folder by just doing a plain open anyway!  If
  119. \ this fails with a "file not found", we call ?USE_PATHS which either does
  120. \ nothing (if we're not using a path designator file), or calls our PATHSMOD
  121. \ module to look at a PD file and try using those paths to find the wanted
  122. \ file.
  123.  
  124. : DO_OPEN  {  fcb mode -- rc } 
  125.     1 ++> open_cnt
  126.     ^base 48 + @                    \ DirID
  127.     ^base 22 + w@                    \ vol ref#
  128.     or  HFS? not  or                \ Either non-zero, or not HFS?
  129.     use_paths? not  or                \ Or paths disabled?
  130.     IF                                \ Yes: just do a normal open, and get out.
  131.         fcb mode (open)  EXIT
  132.     THEN
  133.                                     \ Maybe use HFS paths:
  134.     fcb mode (open) dup  0EXIT        \ Try default folder first
  135.                                     \ -- out if we found it
  136.     dup FNF <>  ?EXIT                \ If err wasn't FNF, get out
  137.     use_paths?  0EXIT                \ If paths disabled, out with FNF
  138.     drop  fcb mode open_with_paths  ;
  139.  
  140.  
  141. :class   FILE    super{ object }        general
  142.  
  143. 134    bytes        FCB            \ max parameter block (108 but for hgetvinfo)
  144.  
  145. record    FSSpec
  146. {    int            FSvRefNum
  147.     var            FSDirID
  148. 64    bytes        FileName
  149. }
  150.  
  151. :m CLEAR:        \ Clears the fcb, except for the filename.
  152.     ^base  18 erase  ^base 22 +  112 erase  ;m
  153.  
  154. :m SETNAMEPTR:    \ Sets filename pointer in the FCB.
  155.     ^base 140 +  ^base !fptr  ;m
  156.  
  157. :m NAME:        \ ( addr len -- )  Assigns file name to fcb.  Rest cleared.
  158.     setNamePtr: self  clear: self
  159.     ^base 140 +  >r                    \ Addr of filename (at end of fcb)
  160.     r@  64 blanks
  161.     ( addr len )  64 min  r>  >str255  drop  ;m
  162.  
  163. :m SETDIRID:    \ ( dirid -- )  Sets the DirID for the fcb
  164.     ^base 48 +  !  ;m
  165.  
  166. :m GETDIRID:    \ ( -- dirid )  Gets the DirID for the fcb
  167.     ^base 48 +  @  ;m
  168.  
  169. :m GETFREF:    \ ( -- fref )  Gets the file ref number.
  170.     ^base 24 +  w@  ;m
  171.  
  172. :m SETFREF:
  173.     ^base 24 +  w!  ;m
  174.  
  175. :m SETVREF:    \ ( vref# -- )  Sets the volRefNum for the fcb
  176.     ^base 22 +  w!  ;m
  177.  
  178. :m GETVREF:    \ ( -- vref# )  Gets the volRefNum for the fcb
  179.     ^base 22 +  w@  ;m
  180.  
  181.  
  182. :m CLOSE:    \ ( -- rc )   Needs to clear the file RefNum field,
  183.             \ as advised in Mac Tech note # 102.  In fact we clear
  184.             \ the whole fcb except the name and Vref, so we can reuse
  185.             \ the fcb for a subsequent operation without the extra info
  186.             \ left by read and write calls being interpreted as HFS info.
  187.             
  188.     ^base  (close)  getVref: self  clear: self  setVref: self
  189.     dup if  1 ++> close_err_cnt  else  -1 ++> open_cnt  then  ;m
  190.  
  191.  
  192. :m OPEN:    \ ( -- rc )
  193.     ^base 0 do_open  ;m
  194.  
  195. :m OPENREADONLY:
  196.     ^base 1 do_open  ;m
  197.  
  198.  
  199. :m NEW:    ^base  (make)  ;m
  200.  
  201. :m DELETE:    ^base (delete)  ;m
  202.  
  203. :m MOVETO:    \ ( byteoffset -- rc )  Positions relative to start of file
  204.     ^base 1 rot  (lseek)  ;m
  205.  
  206. :m POS:        \ ( -- byteoffset )
  207.     ^base  $ 2E +  @  ;m
  208.  
  209. :m SETEOF:    \ ( pos -- rc )  Sets end-of-file to absolute byte position
  210.     ^base 28 + !  ^base fdos$ a012  ;m
  211.  
  212. :m CREATE:  { \ volID -- rc } 
  213.             \ Opens and resets file or creates new if not present.
  214.     1 ++> open_cnt
  215.     ^base 0 (open)                \ Attempt to open - don't use paths
  216.     ?dup
  217.     IF    dup FNF =
  218.         IF    drop
  219.             new: self  ?dup NIF  ^base 0 (open)  THEN
  220.         THEN
  221.     ELSE
  222.         0 setEOF: self
  223.     THEN  ;m
  224.  
  225. :m LAST:        \ Positions to end of file.
  226.     big# moveto: self  drop  ;m
  227.  
  228. :m SIZE:        \ ( -- #bytes )  Returns logical eof for file currently open
  229.     ^base fdos$ a011  drop ^base 28 + @  ;m
  230.  
  231. :m BYTESREAD:    \ ( -- n )  Returns actual bytes read.
  232.     ^base 40 + @  ;m
  233.  
  234. :m FCB:  ( -- fcb )     ^base  ;m
  235.  
  236. :m RESULT:    \ ( -- rc )  Returns the last I/O result code.
  237.     ^base 16 + w@  ;m
  238.  
  239. :m MODE:        \ ( posMode -- )  Sets position mode
  240.     ^base 44 + w!  ;m
  241.  
  242.  
  243. :m WAIT:    \ ( -- rc )  Waits for asynch I/O on this file to finish.
  244.     BEGIN    ^base busy =
  245.         NIF   ^base 16 + w@x  EXIT  THEN
  246.         pause
  247.     AGAIN  ;m
  248.  
  249. :m ?WAIT:    \ ( rc1 -- rc2 )
  250.     asynch?
  251.     NIF        drop  wait: self
  252.     ELSE    false -> asynch?
  253.     THEN   ;m
  254.  
  255.  
  256. :m READ:        \ ( addr length -- rc )
  257.     0 mode: self ^base swap rot
  258.     ^base (asy)  (read)  ?wait: self  ;m
  259.  
  260. :m READLINE:    \ ( addr maxLen -- rc )  Reads terminating with CR
  261.     $ 0D80 mode: self  ^base  swap rot
  262.     ^base (asy)  (read)  ?wait: self  ;m
  263.  
  264. :m WRITE:        \ ( addr length -- rc )
  265.     ^base  swap rot
  266.     ^base (asy)  (write)  ?wait: self  ;m
  267.  
  268. :m SETNAME:        \ Gets name from input stream, and assigns to fcb.
  269.     & "  parse-word  name: self  ;m
  270.  
  271. :m GETNAME:        \ ( -- addr len )  Returns filename
  272.     addr: fileName  count  ;m
  273.  
  274. :m PRINT:        \ Prints the filename.
  275.     getName: self  type  ;m
  276.  
  277. :m GETFILEINFO:        \ ( -- rc )  Fills the parameter block with file info
  278.     ^base fdos$ A20C  ;m
  279.  
  280. :m SETFILEINFO:        \ ( -- rc )
  281.     ^base fdos$ A20D  ;m
  282.  
  283. :m SET:  { ftyp sig -- }            \ Sets file type, signature.
  284.     getDirID: self                    \ Save DirID
  285.     0 setDirID: self                \ and clear it (otherwise we'll get
  286.     getFileInfo: self  drop            \  "file not found")
  287.     sig  ^base  $ 24 +  !            \ Set signature
  288.     ftyp ^base  $ 20 +  !            \ Set type
  289.     0 setDirID: self
  290.     setFileInfo: self  drop
  291.     setDirID: self  ;m                \ Restore DirID
  292.  
  293.  
  294. :m DRIVE:    \ ( drive# -- )  set default drive to drive#
  295.     clear: self  setVRef: self  ^base fdos$ a015
  296.     ?error 165  ;m
  297.  
  298.  
  299. :m ACCEPT:  { addr len \ #chrs eof? -- #chrs eof? }     \ ACCEPTs from disk.
  300.     echo? IF  addr len erase  THEN        \ So the typed line is OK
  301.     addr len  readLine: self  -> eof?
  302.     bytesRead: self  eof? NIF  1-  THEN  -> #chrs
  303.     #chrs 0=  eof? and  IF  0  true  EXIT  THEN
  304.     addr #chrs +  c@  13 <>
  305.     IF                                \ Overlength line. Probably a comment.
  306.         BEGIN                        \ Gobble to CR or EOF
  307.             pad 100  readLine: self  -> eof?
  308.             eof?
  309.             IF        true
  310.             ELSE    pad  bytesRead: self  1-  +  c@ 13 =
  311.             THEN
  312.         UNTIL
  313.     THEN
  314.     #chrs -> len
  315.     echo?
  316.     IF    addr len type  cr  THEN
  317.     BEGIN                            \ Loop to convert tabs to blanks
  318.         addr len  9 scan  -> len  -> addr
  319.         len
  320.     WHILE
  321.         bl addr c!
  322.     REPEAT
  323.     #chrs  false   ;m
  324.  
  325.  
  326. :m RENAME: { taddr tlen -- rc } 
  327.     taddr tlen str255
  328.     ^base 28 + !  ^base fdos$ A00B  ;m
  329.  
  330.  
  331. :m GETTYPE:        \ ( -- type )
  332.     ^base 32 + @  ;m
  333.  
  334. :m FLUSHVOL:
  335.     ^base fdos$ A013  drop  ;m
  336.  
  337.  
  338. :m CLASSINIT:        clear: self  setNamePtr: self  ;m
  339.  
  340.  
  341. \ Standard file package calls.  If the value SFDlgHook is non-zero, we take it as the
  342. \ address of a dialog hook routine.
  343.  
  344. private
  345.  
  346. :m SFPCALL:        \ ( various get? -- b )  Calls a Standard File Package routine
  347.     classinit: self                        \ Make sure name pointer is right
  348.     ['] SFrec  newObj: SFhdl
  349.     obj: SFhdl  -> SFobj
  350.     IF    stdGet: SFobj  ELSE  stdPut: SFobj  THEN
  351.     IF    getVRefNum: SFobj  clear: self  setVref: self
  352.         getName: SFobj  count  addr: fileName  place
  353.         true
  354.     ELSE
  355.         false
  356.     THEN
  357.     release: SFhdl  ;m
  358.  
  359. public
  360.  
  361. :m STDGET:    \ ( type0 ...typeN #types -- bool )
  362.     true sfpCall: self  ;m
  363.  
  364. :m STDPUT:    \ ( pAddr pLen nAddr nLen -- bool )
  365.     false sfpCall: self  ;m
  366.  
  367. ;class 
  368.  
  369.  
  370. ' fFcb  set_to_class  file            \ Make fFcb a FILE objPtr
  371. 6    fFcb 8 -    w!
  372. ' file    fFcb 6 -    reloc!
  373. -6    fFcb 2 -    w!
  374.  
  375.  
  376. \ GetDirID returns the dirID of the last directory opened by a
  377. \ standard file call.
  378.  
  379. : GETDIRID    $ 398 @  ;
  380.  
  381.  
  382. \ FileList keeps a stack of open load files for nested loads.
  383.  
  384. objPtr    TOPFILE  class_is  file
  385.  
  386.  
  387. :class     FILELIST  super{ handleArray } 
  388.  
  389. :m DROP:
  390.     top: super                        \ Give error if empty
  391.     close: topFile  drop
  392.     drop: super
  393.     size: super  NIF  nilP  ELSE  obj: self  THEN
  394.     -> topFile
  395.     false -> endload?   ;m
  396.  
  397. :m PUSHNEW:        \ Adds a new file to the stack
  398.     ['] file  pushNewObj: self
  399.     false -> endload?
  400.     obj: self  -> topFile            \ Note this locks the file object
  401.                                     \ -- this is what we want.
  402.     0 setVref: topFile   ;m
  403.  
  404. :m CLEAR:    \ Removes all currently open files
  405.     false -> endload?
  406.     get: size  0EXIT
  407.     type# 180  ( File stack: )  cr  top: self
  408.     get: size  FOR
  409.         print: topFile  cr  drop: self
  410.     NEXT  ;m
  411.  
  412. ;class 
  413.  
  414.  
  415. 10    fileList    LOADFILE
  416.  
  417. 0    value        FILESTART_DP
  418. 0    value        CNT
  419. 0    value        SvLATEST
  420.  
  421.  
  422. : LOGIT
  423.     state  0EXIT                    \ Out if we're not compiling
  424.     here filestart_DP -  pad w!
  425.     pos: topFile  src-len -
  426.     pad 2+  !
  427.     pad 6  add: $lg1  ;
  428.  
  429.  
  430. 0    value    LASTPOS
  431.  
  432. : LOGCR
  433.     state  0EXIT
  434.     here lastPos <=  ?EXIT
  435.     here -> lastPos
  436.     pad 14 erase
  437.     here filestart_DP -  pad w!
  438.     latest svLatest <> IF  true pad 4+ c!  latest -> svLatest  THEN
  439.     pad 14  add: $lg2  ;
  440.  
  441.  
  442. : (FREFILL)        \ ( -- flag )  Does a refill from a file.
  443.     echo?
  444.     IF        ?pause
  445.     ELSE    cnt NIF  ?pause  20 -> cnt  else  1 --> cnt  THEN
  446.     THEN
  447.     log? IF  logCR  THEN
  448.     tib tibLen  accept: topfile  ( #chrs eof? ) -> endload?  #tib !
  449.     set_source  endload? 0=  ;
  450.  
  451. ' (Frefill) -> Frefill
  452.  
  453.  
  454. : (LD)
  455.     BEGIN
  456.         endload? IF  false -> endload?  EXIT  THEN
  457.         topfile -> source-ID  (Frefill)  IF  interpret  THEN
  458.         state not  echo? and  fWind? and  IF  ok  THEN
  459.     AGAIN  ;
  460.  
  461.  
  462. false    value    DO_CR?
  463.  
  464. : ?file_open_error  { OSErr -- }
  465.     OSErr  0EXIT                        \ out if no error
  466.     getName: topfile  type
  467.     OSErr FNF = IF  132 die  THEN        \ file not found
  468.     OSErr . cr  155 die                    \ other error opening file
  469. ;
  470.  
  471.     
  472. : LOADTOP  {  \ svCurs svHere svDepth -- } 
  473.                             \ Interprets the file as a Mops source file.
  474.     openReadOnly: topfile  ?file_open_error
  475.     curs -> svCurs  -curs
  476.     cr
  477.     size: loadFile 2*  spaces  type# 173 ( Loading: ) 
  478.     getName: topfile  type
  479.     log? IF
  480.         create_log  ['] logit  -> logVec
  481.         0 -> svLatest
  482.     THEN
  483.     here -> svHere  depth -> svDepth
  484.     false -> endload?  false -> do_cr?
  485.     (ld)
  486.     ['] null  -> logvec
  487.     close: topfile  drop  log? IF write_log  THEN
  488.     do_cr?
  489.     IF  cr  size: loadFile 2*  ELSE  2  THEN  spaces  true -> do_cr?
  490.     here svHere -  ." Size: "  .
  491.     size: loadFile 1 <= IF  cr  THEN
  492.     depth svDepth <> IF  cr msg# 75  THEN
  493.                     \ Warning - stack depth different after load
  494.     svCurs -> curs  ;
  495.  
  496.  
  497. : ENDLOAD        true -> endload?  0 -> src-len  ;
  498.  
  499.  
  500. \ Nesting loader.  Usage: // filename
  501.  
  502. : //  {  \ svcurs addr len -- } 
  503.     pushNew: loadFile  setName: topFile
  504.     getName: topFile  mark_file
  505.     loadTop
  506.     drop: loadFile  ;
  507.  
  508.  
  509. \        ======= Module support ========
  510.  
  511. : NOMOD        -1 -> modbase  -1 -> MBcomp  0 -> CompMod  ;
  512.  
  513.  
  514. : LDFROMMOD {  newModbase \ svModbase svMBcomp -- } 
  515.         \ Load from a module.  We save and restore the current
  516.         \ modbase and MBcomp value, in case the load changes them.
  517.  
  518.     modbase -> svModbase  MBcomp -> svMBcomp
  519.     newModbase  dup  -> modbase  -> MBcomp
  520.     loadtop
  521.     svModbase -> modbase  svMBcomp -> MBcomp  ;
  522.  
  523.  
  524. \        ========== Save ==========
  525.  
  526. 'type COM    constant    SAVETYPE    \ file type = 'COM '
  527. 'type MOPS    constant    SAVESIG        \ Signature = 'MOPS'
  528.  
  529. : SAVE_THIS    \ ( -- addr len )  Defines what to save
  530.     ['] latest  here over -  ;
  531.  
  532.  
  533. \ PURGE gets rid of all loaded modules.  It is defined in the file Modules.
  534. \ SAVE needs to call it first, so that saved dic images don't appear to
  535. \ reference loaded modules which aren't really loaded.  So that we can call
  536. \ SAVE before Modules is loaded, we make PURGE a vector rather than a
  537. \ forward definition.
  538.  
  539. ' null    vect    PURGE
  540.  
  541.  
  542. : (SAVE)  {  \ savdp savlatest -- rc } 
  543.     create: ffcb  ?error 107
  544.     dp -> savdp  latest -> savlatest
  545.     save_this                        \ Call before we clobber DP
  546.     dp    ['] dp -  -> dp                \ Here we make DP and LATEST relative
  547.     latest    ['] dp -  -> latest        \  to DP so we can set them up when
  548.                                     \  saved image is read in
  549.     purge                            \ Purge modules so saved image has them all
  550.                                     \  unloaded
  551.     0 -> bufPtr                        \ Must be zero in saved dics
  552.     true -> savingDic?                \ Stops PAUSE from doing anything during
  553.                                     \  asynch I/O (could try to call a module,
  554.                                     \  but they're purged)
  555.     write: ffcb                        \ Leave return code on stack for caller
  556.     false -> savingDic?
  557.     savdp -> dp  savlatest -> latest    \ and DP and LATEST
  558.     savetype savesig set: ffcb
  559.     close: ffcb drop
  560. \    type# 101 ( Saved: )  getname: ffcb  type  cr  ;
  561. ;
  562.  
  563. : SAVE        \ Takes name from input stream.  Redefined later in Frontend.
  564.     setname: ffcb  (save)  ?error 105  ;
  565.  
  566.  
  567. \ CL2 is the next cleanup word - it cleans up all file stuff on abort,
  568. \ as well as whatever we were doing before (see CL1 in file Class).
  569.  
  570. : CL2
  571.     clear: loadfile  close: ffcb drop
  572.     nomod  release: $lg1  release: $lg2
  573.     ['] null  -> logvec  false -> endload?
  574.     false -> savingDic?
  575.     cl1  ;
  576.  
  577.  
  578. : FILINIT
  579.     ['] file  dup  ['] fFcb  4+  reloc!
  580.     fFcb 18 + @                    \ Name pointer - doc name may not be in fFcb
  581.     count  32 min  myDocName place
  582.     fFcb  make_obj
  583.     clear: loadfile  ;
  584.  
  585.  
  586. ' filinit    -> objinit
  587. ' cl2        -> abortvec
  588.  
  589.  
  590. : -ECHO        false -> echo?  ;
  591. : +ECHO        true  -> echo?  ;
  592.  
  593. cr
  594. .( saving interim.dic.  Now type)  cr
  595. .( // sys.ld)  cr
  596. .( to load the rest of the system.)  cr
  597.  
  598. save interim.dic
  599.